home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tcl / menu.tcl < prev    next >
Text File  |  1992-08-19  |  9KB  |  302 lines
  1. # menu.tcl --
  2. #
  3. # This file contains Tcl procedures used to manage Tk menus and
  4. # menubuttons.  Most of the code here is dedicated to support for
  5. # menu traversal via the keyboard.
  6. #
  7. # $Header: /user6/ouster/wish/scripts/RCS/menu.tcl,v 1.11 92/08/08 14:49:55 ouster Exp $ SPRITE (Berkeley)
  8. #
  9. # Copyright 1992 Regents of the University of California
  10. # Permission to use, copy, modify, and distribute this
  11. # software and its documentation for any purpose and without
  12. # fee is hereby granted, provided that this copyright
  13. # notice appears in all copies.  The University of California
  14. # makes no representations about the suitability of this
  15. # software for any purpose.  It is provided "as is" without
  16. # express or implied warranty.
  17. #
  18.  
  19. # The procedure below is publically available.  It is used to indicate
  20. # the menus associated with a particular top-level window, for purposes
  21. # of keyboard menu traversal.  Its first argument is the path name of
  22. # a top-level window, and any additional arguments are the path names of
  23. # the menu buttons associated with that top-level window, in the order
  24. # they should be traversed.  If no menu buttons are named, the procedure
  25. # returns the current list of menus for w.  If a single empty string is
  26. # supplied, then the menu list for w is cancelled.  Otherwise, tk_menus
  27. # sets the menu list for w to the menu buttons.
  28.  
  29. proc tk_menus {w args} {
  30.     global tk_priv
  31.  
  32.     if {$args == ""} {
  33.     if [catch {set result [set tk_priv(menusFor$w)]}] {
  34.         return ""
  35.     }
  36.     return $result
  37.     }
  38.  
  39.     if {$args == "{}"} {
  40.     catch {unset tk_priv(menusFor$w)}
  41.     return ""
  42.     }
  43.  
  44.     set tk_priv(menusFor$w) $args
  45. }
  46.  
  47. # The procedure below is publically available.  It takes any number of
  48. # arguments taht are names of widgets or classes.  It sets up bindings
  49. # for the widgets or classes so that keyboard menu traversal is possible
  50. # when the input focus is in those widgets or classes.
  51.  
  52. proc tk_bindForTraversal args {
  53.     foreach w $args {
  54.     bind $w <Alt-KeyPress> {tk_traverseToMenu %W %A}
  55.     bind $w <F10> {tk_firstMenu %W}
  56.     }
  57. }
  58.  
  59. # The procedure below does all of the work of posting a menu (including
  60. # unposting any other menu that might currently be posted).  The "w"
  61. # argument is the name of the menubutton for the menu to be posted.
  62. # Note:  if $w is disabled then the procedure does nothing.
  63.  
  64. proc tk_mbPost {w} {
  65.     global tk_priv tk_strictMotif
  66.     if {[lindex [$w config -state] 4] == "disabled"} {
  67.     return
  68.     }
  69.     set cur $tk_priv(posted)
  70.     if {$cur == $w} {
  71.     return
  72.     }
  73.     if {$cur != ""} tk_mbUnpost
  74.     set tk_priv(relief) [lindex [$w config -relief] 4]
  75.     $w config -relief raised
  76.     set tk_priv(cursor) [lindex [$w config -cursor] 4]
  77.     $w config -cursor arrow
  78.     $w post
  79.     grab -global $w
  80.     set tk_priv(posted) $w
  81.     if {$tk_priv(focus) == ""} {
  82.     set tk_priv(focus) [focus]
  83.     }
  84.     set menu [lindex [$w config -menu] 4]
  85.     set tk_priv(activeBg) [lindex [$menu config -activebackground] 4]
  86.     set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4]
  87.     if $tk_strictMotif {
  88.     $menu config -activebackground [lindex [$menu config -background] 4]
  89.     $menu config -activeforeground [lindex [$menu config -foreground] 4]
  90.     }
  91.     focus $menu
  92. }
  93.  
  94. # The procedure below does all the work of unposting the menubutton that's
  95. # currently posted.  It takes no arguments.
  96.  
  97. proc tk_mbUnpost {} {
  98.     global tk_priv
  99.     if {$tk_priv(posted) != ""} {
  100.     $tk_priv(posted) config -relief $tk_priv(relief)
  101.     $tk_priv(posted) config -cursor $tk_priv(cursor)
  102.     $tk_priv(posted) config -activebackground $tk_priv(activeBg)
  103.     $tk_priv(posted) config -activeforeground $tk_priv(activeFg)
  104.     $tk_priv(posted) unpost
  105.     grab none
  106.     focus $tk_priv(focus)
  107.     set tk_priv(focus) ""
  108.     set menu [lindex [$tk_priv(posted) config -menu] 4]
  109.     $menu config -activebackground $tk_priv(activeBg)
  110.     $menu config -activeforeground $tk_priv(activeFg)
  111.     set tk_priv(posted) {}
  112.     }
  113. }
  114.  
  115. # The procedure below is invoked to implement keyboard traversal to
  116. # a menu button.  It takes two arguments:  the name of a window where
  117. # a keystroke originated, and the ascii character that was typed.
  118. # This procedure finds a menu bar by looking upward for a top-level
  119. # window, then looking for a window underneath that named "menu".
  120. # Then it searches through all the subwindows of "menu" for a menubutton
  121. # with an underlined character matching char.  If one is found, it
  122. # posts that menu.
  123.  
  124. proc tk_traverseToMenu {w char} {
  125.     global tk_priv
  126.     if {$char == ""} {
  127.     return
  128.     }
  129.     set char [string tolower $char]
  130.  
  131.     foreach mb [tk_getMenuButtons $w] {
  132.     if {[winfo class $mb] == "Menubutton"} {
  133.         set char2 [string index [lindex [$mb config -text] 4] \
  134.             [lindex [$mb config -underline] 4]]
  135.         if {[string compare $char [string tolower $char2]] == 0} {
  136.         tk_mbPost $mb
  137.         [lindex [$mb config -menu] 4] activate 0
  138.         return
  139.         }
  140.     }
  141.     }
  142. }
  143.  
  144. # The procedure below is used to implement keyboard traversal within
  145. # the posted menu.  It takes two arguments:  the name of the menu to
  146. # be traversed within, and an ASCII character.  It searches for an
  147. # entry in the menu that has that character underlined.  If such an
  148. # entry is found, it is invoked and the menu is unposted.
  149.  
  150. proc tk_traverseWithinMenu {w char} {
  151.     if {$char == ""} {
  152.     return
  153.     }
  154.     set char [string tolower $char]
  155.     set last [$w index last]
  156.     for {set i 0} {$i <= $last} {incr i} {
  157.     if [catch {set char2 [string index \
  158.         [lindex [$w entryconfig $i -label] 4] \
  159.         [lindex [$w entryconfig $i -underline] 4]]}] {
  160.         continue
  161.     }
  162.     if {[string compare $char [string tolower $char2]] == 0} {
  163.         tk_mbUnpost
  164.         $w invoke $i
  165.         return
  166.     }
  167.     }
  168. }
  169.  
  170. # The procedure below takes a single argument, which is the name of
  171. # a window.  It returns a list containing path names for all of the
  172. # menu buttons associated with that window's top-level window, or an
  173. # empty list if there are none.
  174.  
  175. proc tk_getMenuButtons w {
  176.     global tk_priv
  177.     set top [winfo toplevel $w]
  178.     if [catch {set buttons [set tk_priv(menusFor$top)]}] {
  179.     return ""
  180.     }
  181.     return $buttons
  182. }
  183.  
  184. # The procedure below is used to traverse to the next or previous
  185. # menu in a menu bar.  It takes one argument, which is a count of
  186. # how many menu buttons forward or backward (if negative) to move.
  187. # If there is no posted menu then this procedure has no effect.
  188.  
  189. proc tk_nextMenu count {
  190.     global tk_priv
  191.     if {$tk_priv(posted) == ""} {
  192.     return
  193.     }
  194.     set buttons [tk_getMenuButtons $tk_priv(posted)]
  195.     set length [llength $buttons]
  196.     for {set i 0} 1 {incr i} {
  197.     if {$i >= $length} {
  198.         return
  199.     }
  200.     if {[lindex $buttons $i] == $tk_priv(posted)} {
  201.         break
  202.     }
  203.     }
  204.     incr i $count
  205.     while 1 {
  206.     while {$i < 0} {
  207.         incr i $length
  208.     }
  209.     while {$i >= $length} {
  210.         incr i -$length
  211.     }
  212.     set mb [lindex $buttons $i]
  213.     if {[lindex [$mb configure -state] 4] != "disabled"} {
  214.         break
  215.     }
  216.     incr i $count
  217.     }
  218.     tk_mbUnpost
  219.     tk_mbPost $mb
  220.     [lindex [$mb config -menu] 4] activate 0
  221. }
  222.  
  223. # The procedure below is used to traverse to the next or previous entry
  224. # in the posted menu.  It takes one argument, which is 1 to go to the
  225. # next entry or -1 to go to the previous entry.  Disabled entries are
  226. # skipped in this process.
  227.  
  228. proc tk_nextMenuEntry count {
  229.     global tk_priv
  230.     if {$tk_priv(posted) == ""} {
  231.     return
  232.     }
  233.     set menu [lindex [$tk_priv(posted) config -menu] 4]
  234.     set length [expr [$menu index last]+1]
  235.     set i [$menu index active]
  236.     if {$i == "none"} {
  237.     set i 0
  238.     } else {
  239.     incr i $count
  240.     }
  241.     while 1 {
  242.     while {$i < 0} {
  243.         incr i $length
  244.     }
  245.     while {$i >= $length} {
  246.         incr i -$length
  247.     }
  248.     if {[catch {$menu entryconfigure $i -state} state] == 0} {
  249.         if {[lindex $state 4] != "disabled"} {
  250.         break
  251.         }
  252.     }
  253.     incr i $count
  254.     }
  255.     $menu activate $i
  256. }
  257.  
  258. # The procedure below invokes the active entry in the posted menu,
  259. # if there is one.  Otherwise it does nothing.
  260.  
  261. proc tk_invokeMenu {menu} {
  262.     set i [$menu index active]
  263.     if {$i != "none"} {
  264.     tk_mbUnpost
  265.     update idletasks
  266.     $menu invoke $i
  267.     }
  268. }
  269.  
  270. # The procedure below is invoked to keyboard-traverse to the first
  271. # menu for a given source window.  The source window is passed as
  272. # parameter.
  273.  
  274. proc tk_firstMenu w {
  275.     set mb [lindex [tk_getMenuButtons $w] 0]
  276.     if {$mb != ""} {
  277.     tk_mbPost $mb
  278.     [lindex [$mb config -menu] 4] activate 0
  279.     }
  280. }
  281.  
  282. # The procedure below is invoked when a button-1-down event is
  283. # received by a menu button.  If the mouse is in the menu button
  284. # then it posts the button's menu.  If the mouse isn't in the
  285. # button's menu, then it deactivates any active entry in the menu.
  286. # Remember, event-sharing can cause this procedure to be invoked
  287. # for two different menu buttons on the same event.
  288.  
  289. proc tk_mbButtonDown w {
  290.     global tk_priv
  291.     if {[lindex [$w config -state] 4] == "disabled"} {
  292.     return
  293.     } 
  294.     if {$tk_priv(inMenuButton) == $w} {
  295.     tk_mbPost $w
  296.     }
  297.     set menu [lindex [$tk_priv(posted) config -menu] 4]
  298.     if {$tk_priv(window) != $menu} {
  299.     $menu activate none
  300.     }
  301. }
  302.